#!/usr/bin/perl

package PerLISP::LispOps;

require Exporter;

use strict;
use warnings;

use PerLISP::Cons;

our @ISA = qw(Exporter);
our @EXPORT = 
  qw( _cons
      _car
      _cdr
      _eq
      _atomic
      _nill
      
      _caar 
      _cadr 
      _caddr 
      _cdar 
      _cadar

      _dump );

sub _cons;
sub _car;
sub _cdr;
sub _eq;
sub _atomic;



sub _cons {
  my ($car, $cdr) = @_;
  return PerLISP::Cons->new( $car, $cdr );
}

sub _car {
  my $cons = shift;
  return $cons->get_car;
}

sub _cdr {
  my $cons = shift;
  return $cons->get_cdr;
}

sub _eq {
  my ( $a, $b ) = @_;
  if ( _atomic( $a ) and _atomic( $b ) ) {
    return $a eq $b;
  }
  else {
    return '';
  }
}

sub _atomic {
  my $var = shift;
  eval {
    return not $var->isa( 'PerLISP::Cons' );
  };
  if ( $@ ) {
    return 1;
  } 
  else { 
    return not $var->isa( 'PerLISP::Cons' );
  }
}
 
sub _nill {
  my $var = shift;
  return 1 unless $var;
  return 0 if _atomic( $var );
  return 1 unless $var->get_car || $var->get_cdr;
  return 0;
}

##EXTRAS##
sub _caar {
  my $list = shift;
  return _car( _car( $list ));
}

sub _cadr {
  my $list = shift;
  return _car( _cdr( $list ));
}

sub _caddr {
  my $list = shift;
  return _car( _cdr( _cdr( $list )));
}

sub _cdar {
  my $list = shift;
  return _cdr( _car( $list ));
}

sub _cadar {
  my $list = shift;
  return _car( _cdr( _car( $list )));
}
 

##BONUS##

sub _dump {
  my $var = shift;
  my $return = "(";
  
  until ( _nill( $var )) {
    if ( _atomic( $var )) {
      return $var;
    }
    my $car = _car( $var );
    if ( _atomic( $car )) {
      $return .= $car;
    }
    else {
      $return .= _dump( $car );
    }
    $return .= " " unless _nill( _cdr( $var ));
    $var = _cdr( $var );
  }
  return $return . ")";
}
  
1;
__END__
